home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
ada_gnu
/
adainc
/
s-tasque.adb
< prev
next >
Wrap
Text File
|
1996-01-30
|
9KB
|
305 lines
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . Q U E U I N G --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU Library General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. GNARL is distributed in the hope that it will be use- --
-- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- --
-- eral Library Public License for more details. You should have received --
-- a copy of the GNU Library General Public License along with GNARL; see --
-- file COPYING.LIB. If not, write to the Free Software Foundation, 675 --
-- Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with System.Task_Primitives; use System.Task_Primitives;
package body System.Tasking.Queuing is
-- Entry Queues implemented as doubly linked list, priority ordered
-------------
-- Enqueue --
-------------
-- Enqueue call priority ordered, FIFO at same priority level
procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
Temp : Entry_Call_Link := E.Head;
begin
if Temp = null then
Call.Prev := Call;
Call.Next := Call;
E.Head := Call;
E.Tail := Call;
else
loop -- find the entry that the new guy should precede
exit when Call.Prio > Temp.Prio;
Temp := Temp.Next;
if Temp = E.Head then
Temp := null;
exit;
end if;
end loop;
if Temp = null then -- insert at tail
Call.Prev := E.Tail;
Call.Next := E.Head;
E.Tail := Call;
else
Call.Prev := Temp.Prev;
Call.Next := Temp;
if Temp = E.Head then -- insert at head
E.Head := Call;
end if;
end if;
Call.Prev.Next := Call;
Call.Next.Prev := Call;
end if;
end Enqueue;
-------------
-- Dequeue --
-------------
-- Dequeue call from entry_queue E
procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
Prev : Entry_Call_Link;
begin
-- If empty queue, simply return
if E.Head = null then
return;
end if;
Call.Prev.Next := Call.Next;
Call.Next.Prev := Call.Prev;
if E.Head = Call then
if E.Tail = Call then
E.Head := null; -- case of one element
E.Tail := null;
else
E.Head := Call.Next;
end if;
elsif E.Tail = Call then
E.Tail := Call.Prev;
end if;
-- Successfully dequeued
Call.Prev := null;
Call.Next := null;
end Dequeue;
----------
-- Head --
----------
-- Return the head of entry_queue E
function Head (E : in Entry_Queue) return Entry_Call_Link is
begin
return E.Head;
end Head;
------------------
-- Dequeue_Head --
------------------
-- Remove and return the head of entry_queue E
procedure Dequeue_Head
(E : in out Entry_Queue;
Call : out Entry_Call_Link)
is
Temp : Entry_Call_Link;
begin
-- If empty queue, return null pointer
if E.Head = null then
Call := null;
return;
end if;
Temp := E.Head;
if E.Head = E.Tail then
E.Head := null; -- case of one element
E.Tail := null;
else
E.Head := Temp.Next;
Temp.Prev.Next := Temp.Next;
Temp.Next.Prev := Temp.Prev;
end if;
-- Successfully dequeued
Temp.Prev := null;
Temp.Next := null;
Call := Temp;
end Dequeue_Head;
-------------
-- Onqueue --
-------------
-- Return True if Call is on any entry_queue at all
function Onqueue (Call : Entry_Call_Link) return Boolean is
begin
-- Utilize the fact that every queue is circular, so if Call
-- is on any queue at all, Call.Next must NOT be null.
return Call.Next /= null;
end Onqueue;
-------------------
-- Count_Waiting --
-------------------
-- Return number of calls on the waiting queue of E
function Count_Waiting (E : in Entry_Queue) return Natural is
Count : Natural;
Temp : Entry_Call_Link;
begin
Count := 0;
if E.Head /= null then
Temp := E.Head;
loop
Count := Count + 1;
exit when E.Tail = Temp;
Temp := Temp.Next;
end loop;
end if;
return Count;
end Count_Waiting;
----------------------------
-- Select_Task_Entry_Call --
----------------------------
-- Select an entry for rendezvous
procedure Select_Task_Entry_Call
(Acceptor : Utilities.ATCB_Ptr;
Open_Accepts : Accept_List_Access;
Call : out Entry_Call_Link;
Selection : out Select_Index)
is
Entry_Call : Entry_Call_Link;
Temp_Call : Entry_Call_Link;
Entry_Index : Task_Entry_Index;
Temp_Entry : Task_Entry_Index;
TAS_Result : Boolean;
begin
loop
Entry_Call := null;
for J in Open_Accepts'Range loop
Temp_Entry := Open_Accepts (J).S;
if Temp_Entry /= Null_Task_Entry then
Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
if Temp_Call /= null and then
(Entry_Call = null or else
Entry_Call.Prio < Temp_Call.Prio)
then
Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
Entry_Index := Temp_Entry;
Selection := J;
end if;
end if;
end loop;
if Entry_Call = null then
Selection := No_Rendezvous;
exit;
end if;
-- Guard is open
Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
exit when TAS_Result;
-- TAS_Result = False only when the call is already canceled
-- in that case, we go on to the next call on the queue
end loop;
Call := Entry_Call;
end Select_Task_Entry_Call;
---------------------------------
-- Select_Protected_Entry_Call --
---------------------------------
-- Select an entry of a protected object
procedure Select_Protected_Entry_Call
(Object : Protection_Access;
Barriers : Barrier_Vector;
Call : out Entry_Call_Link)
is
Entry_Call : Entry_Call_Link;
Temp_Call : Entry_Call_Link;
Entry_Index : Protected_Entry_Index;
TAS_Result : Boolean;
begin
loop
Entry_Call := null;
for J in Barriers'Range loop
if Barriers (J) then
Temp_Call := Head (Object.Entry_Queues (J));
if Temp_Call /= null and then
(Entry_Call = null or else
Entry_Call.Prio < Temp_Call.Prio)
then
Entry_Call := Temp_Call;
Entry_Index := J;
end if;
end if;
end loop;
exit when Entry_Call = null;
-- Barrier is open
Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
if Entry_Call.Abortable then
Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
exit when TAS_Result;
-- If call is not abortable, it has already been claimed for us
else
exit;
end if;
end loop;
Call := Entry_Call;
end Select_Protected_Entry_Call;
end System.Tasking.Queuing;
